PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/mee/vbdao/visdata/vdmdi.frm

Visual Basic Form | 1994-10-06 | 41.8 KB | 1,362 lines

VERSION 2.00
Begin MDIForm VDMDI
   Caption         =   "Visual Data"
   ClientHeight    =   6210
   ClientLeft      =   1110
   ClientTop       =   1725
   ClientWidth     =   12420
   Height          =   6900
   Icon            =   0
   Left            =   1050
   LinkTopic       =   "MDIForm1"
   Top             =   1095
   Width           =   12540
   Begin PictureBox Picture1
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      Height          =   285
      Left            =   0
      ScaleHeight     =   255
      ScaleWidth      =   12390
      TabIndex        =   6
      Top             =   5925
      Width           =   12420
      Begin CommonDialog CMD1
         Left            =   11040
         Top             =   0
      End
      Begin Label cMsg
         BackColor       =   &H00C0C0C0&
         Caption         =   "Ready"
         Height          =   195
         Left            =   120
         TabIndex        =   7
         Tag             =   "POLS"
         Top             =   30
         Width           =   8295
      End
   End
   Begin PictureBox ToolBar
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      Height          =   360
      Left            =   0
      ScaleHeight     =   335.075
      ScaleMode       =   0  'User
      ScaleWidth      =   12413.92
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   0
      Visible         =   0   'False
      Width           =   12420
      Begin CheckBox cPassThru
         BackColor       =   &H00C0C0C0&
         Caption         =   "PassThru"
         Height          =   255
         Left            =   5760
         TabIndex        =   10
         Top             =   30
         Visible         =   0   'False
         Width           =   1335
      End
      Begin OptionButton cTableViewSS
         BackColor       =   &H00C0C0C0&
         Caption         =   "Snapshot/Grid"
         Height          =   255
         Left            =   4080
         TabIndex        =   9
         Top             =   30
         Width           =   1597
      End
      Begin OptionButton cDataCtl
         BackColor       =   &H00C0C0C0&
         Caption         =   "Data Ctrl"
         Height          =   255
         Left            =   80
         TabIndex        =   8
         Top             =   30
         Value           =   -1  'True
         Width           =   1095
      End
      Begin CommandButton BeginButton
         Caption         =   "BeginTransaction"
         Height          =   330
         Left            =   7200
         TabIndex        =   5
         Top             =   0
         Width           =   1695
      End
      Begin CommandButton RollBackButton
         Caption         =   "Rollback"
         Height          =   330
         Left            =   8040
         TabIndex        =   4
         Top             =   0
         Visible         =   0   'False
         Width           =   855
      End
      Begin CommandButton CommitButton
         Caption         =   "Commit"
         Height          =   330
         Left            =   7200
         TabIndex        =   3
         Top             =   0
         Visible         =   0   'False
         Width           =   855
      End
      Begin OptionButton cTableView
         BackColor       =   &H00C0C0C0&
         Caption         =   "Dynaset/Grid"
         Height          =   255
         Left            =   2596
         TabIndex        =   2
         Top             =   30
         Width           =   1497
      End
      Begin OptionButton cSingleRecord
         BackColor       =   &H00C0C0C0&
         Caption         =   "No Data Ctrl"
         Height          =   255
         Left            =   1200
         TabIndex        =   1
         Top             =   30
         Width           =   1335
      End
   End
   Begin Menu DBMenu
      Caption         =   "&File"
      Begin Menu DBOpenMain
         Caption         =   "&Open DataBase..."
         Begin Menu DBOpen
            Caption         =   "&MS Access..."
            Index           =   0
         End
         Begin Menu DBOpen
            Caption         =   "&Dbase III..."
            Index           =   1
         End
         Begin Menu DBOpen
            Caption         =   "Db&ase IV..."
            Index           =   2
         End
         Begin Menu DBOpen
            Caption         =   "&FoxPro 2.0..."
            Index           =   3
         End
         Begin Menu DBOpen
            Caption         =   "Fo&xPro 2.5..."
            Index           =   4
         End
         Begin Menu DBOpen
            Caption         =   "&Paradox 3.X..."
            Index           =   5
         End
         Begin Menu DBOpen
            Caption         =   "Pa&radox 4.X..."
            Index           =   6
         End
         Begin Menu DBOpen
            Caption         =   "&Btrieve..."
            Index           =   7
         End
         Begin Menu DBOpen
            Caption         =   "&ODBC..."
            Index           =   8
         End
      End
      Begin Menu DBClose
         Caption         =   "&Close DataBase"
         Shortcut        =   ^C
         Visible         =   0   'False
      End
      Begin Menu DBProperties
         Caption         =   "&Properties..."
         Visible         =   0   'False
      End
      Begin Menu DBNewMain
         Caption         =   "&New..."
         Begin Menu DBNew
            Caption         =   "&MS Access..."
            Index           =   0
         End
         Begin Menu DBNew
            Caption         =   "&Dbase III..."
            Index           =   1
         End
         Begin Menu DBNew
            Caption         =   "Db&ase IV..."
            Index           =   2
         End
         Begin Menu DBNew
            Caption         =   "&FoxPro 2.0..."
            Index           =   3
         End
         Begin Menu DBNew
            Caption         =   "Fo&xPro 2.5..."
            Index           =   4
         End
         Begin Menu DBNew
            Caption         =   "&Paradox 3.X..."
            Index           =   5
         End
         Begin Menu DBNew
            Caption         =   "Pa&radox 4.X..."
            Index           =   6
         End
         Begin Menu DBNew
            Caption         =   "&Btrieve..."
            Index           =   7
         End
         Begin Menu DBNew
            Caption         =   "&ODBC..."
            Index           =   8
         End
      End
      Begin Menu menubar1
         Caption         =   "-"
      End
      Begin Menu DBCompactDB
         Caption         =   "Co&mpact Database..."
      End
      Begin Menu DBRepairDB
         Caption         =   "&Repair Database..."
      End
      Begin Menu menubar3
         Caption         =   "-"
      End
      Begin Menu DBAbout
         Caption         =   "&About..."
      End
      Begin Menu Exit
         Caption         =   "E&xit"
         Shortcut        =   ^X
      End
   End
   Begin Menu TblMenu
      Caption         =   "&Table"
      Visible         =   0   'False
      Begin Menu TblRefresh
         Caption         =   "&Refresh Table List"
         Shortcut        =   ^R
      End
      Begin Menu TblCopyStruct
         Caption         =   "&Copy..."
      End
      Begin Menu TblDelete
         Caption         =   "&Delete Table"
         Shortcut        =   ^D
      End
      Begin Menu TblProperties
         Caption         =   "&Properties..."
      End
      Begin Menu TblAttach
         Caption         =   "&Attach..."
         Visible         =   0   'False
      End
      Begin Menu TblZap
         Caption         =   "Remove &All Records"
      End
      Begin Menu TblPack
         Caption         =   "Pac&k..."
         Visible         =   0   'False
      End
   End
   Begin Menu QueryBuilder
      Caption         =   "&Query!"
      Visible         =   0   'False
   End
   Begin Menu UtilMenu
      Caption         =   "&Utility"
      Visible         =   0   'False
      Begin Menu UtilCloseAll
         Caption         =   "&Close All RecordSet Forms"
      End
      Begin Menu UtilReplace
         Caption         =   "&Global Replace..."
      End
      Begin Menu UtilImportExport
         Caption         =   "&Import/Export..."
      End
   End
   Begin Menu PrefMenu
      Caption         =   "&Preferences"
      Begin Menu PrefOpenOnStartup
         Caption         =   "&Open Last DataBase on Startup"
      End
      Begin Menu menubar4
         Caption         =   "-"
      End
      Begin Menu PrefQueryTimeout
         Caption         =   "&Query Timeout Value..."
      End
      Begin Menu PrefLoginTimeout
         Caption         =   "&Login Timeout Value..."
      End
      Begin Menu PrefMaxRows
         Caption         =   "&Max Grid View Rows..."
      End
      Begin Menu menubar5
         Caption         =   "-"
      End
      Begin Menu PrefShowPerf
         Caption         =   "&Show Performance Numbers"
      End
      Begin Menu PrefAllowSys
         Caption         =   "&Include System Tables"
      End
      Begin Menu PrefDisplaySQL
         Caption         =   "&Display QueryDef SQL Text"
      End
   End
   Begin Menu WinMenu
      Caption         =   "&Window"
      Begin Menu WinTile
         Caption         =   "&Tile"
      End
      Begin Menu WinCascade
         Caption         =   "&Cascade"
      End
      Begin Menu WinArrange
         Caption         =   "&Arrange Icons"
      End
      Begin Menu menubar2
         Caption         =   "-"
      End
      Begin Menu WinTables
         Caption         =   "Ta&bles"
         Shortcut        =   ^T
      End
      Begin Menu WinSQL
         Caption         =   "&SQL"
         Shortcut        =   ^S
      End
   End
   Begin Menu PUMMain
      Caption         =   "PopUpMenu"
      Visible         =   0   'False
      Begin Menu PUMDynaset
         Caption         =   "&Dynaset"
      End
      Begin Menu PUMTable
         Caption         =   "&Open Table"
         Enabled         =   0   'False
      End
      Begin Menu PUMSnapshot
         Caption         =   "&Snapshot"
      End
      Begin Menu PUMRefAtt
         Caption         =   "&Refresh Attachment"
         Enabled         =   0   'False
      End
      Begin Menu PUMMenubar1
         Caption         =   "-"
      End
      Begin Menu PUMProp
         Caption         =   "&Properties..."
      End
      Begin Menu PUMDesign
         Caption         =   "&Design..."
      End
      Begin Menu PUMDelete
         Caption         =   "De&lete"
      End
   End
Option Explicit
Option Compare Binary
Sub BeginButton_Click ()
  On Error GoTo BeginErr
  If gCurrentDB.Transactions = False Then
    Beep
    MsgBox "Transactions not supported by this Driver!"
    Exit Sub
  End If
  gCurrentDB.BeginTrans
  gfDBChanged = False
  gfTransPending = True
  BeginButton.Visible = False
  CommitButton.Visible = True
  RollBackButton.Visible = True
  CommitButton.SetFocus
  GoTo BeginTransEnd
BeginErr:
  ShowError
  Resume BeginTransEnd
BeginTransEnd:
End Sub
Sub CommitButton_Click ()
  On Error GoTo CommitErr
  gCurrentDB.CommitTrans
  gfDBChanged = False
  gfTransPending = False
  BeginButton.Visible = True
  CommitButton.Visible = False
  RollBackButton.Visible = False
  BeginButton.SetFocus
  GoTo DBCommitTransEnd
CommitErr:
  ShowError
  Resume DBCommitTransEnd
DBCommitTransEnd:
End Sub
Sub DBAbout_Click ()
  MsgBar "Press any key to Close About Box", False
  AboutBox.Show MODAL
  MsgBar NULL_STR, False
End Sub
Sub DBClose_Click ()
  On Error GoTo DBCloseErr
  If gfDBChanged Then
    If MsgBox("Data has been changed, Commit it?", MSGBOX_TYPE) = YES Then
      gCurrentDB.CommitTrans
      gfDBChanged = False
    Else
      If MsgBox("RollBack All changes?", MSGBOX_TYPE) = YES Then
        gCurrentDB.Rollback
        gfDBChanged = False
      Else
        Beep
        MsgBox "Can't Close with Transactions Pending!", 48
        Exit Sub
      End If
    End If
  End If
  gTableListSS.Close
  CloseAllDynasets
  gCurrentDB.Close
  fTables.Caption = "<none>"
  fTables.cTableList.Clear
  fTables.TableListLabel.Caption = "Tables:"
  DBProperties.Visible = False
  DBClose.Visible = False
  TblAttach.Visible = False
  TblMenu.Visible = False
  UtilMenu.Visible = False
  ToolBar.Visible = False
  QueryBuilder.Visible = False
  gfDBOpenFlag = False
  gfTransPending = False
  gstDBName = NULL_STR
  gstDataBase = NULL_STR
  gstUserName = NULL_STR
  gstPassword = NULL_STR
  Unload fQuery
  GoTo DBCloseEnd
DBCloseErr:
  ShowError
  Resume DBCloseEnd
DBCloseEnd:
End Sub
Sub DBCompactDB_Click ()
   Dim oldname As String, newname As String
   On Error GoTo CompactAccErr
   'get file name to compact
   CMD1.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
   CMD1.DialogTitle = "Open MS Access Database to Compact"
   CMD1.FilterIndex = 1
   CMD1.Action = 1
   If Len(CMD1.Filename) > 0 Then
     oldname = CMD1.Filename
   Else
     Exit Sub
   End If
getname:
   'get file name to compact to
   CMD1.DialogTitle = "Select MS Access Database to Compact to"
   CMD1.FilterIndex = 1
   CMD1.Filename = NULL_STR
   CMD1.Action = 2
   If Len(CMD1.Filename) > 0 Then
     newname = CMD1.Filename
   Else
     Exit Sub
   End If
   If Dir$(CMD1.Filename) <> "" Then
     If MsgBox("Replace Existing File?", MSGBOX_TYPE) = YES Then
       Kill CMD1.Filename
     Else
       GoTo getname
     End If
   End If
   SetHourglass Me
   MsgBar "Compacting " & oldname & " to " & newname, True
   CompactDatabase oldname, newname, DB_CREATE_GENERAL, DB_VERSION10
   MsgBar NULL_STR, False
   ResetMouse Me
   If MsgBox("Open Newly Compacted Database?", MSGBOX_TYPE) = YES Then
     If gfDBOpenFlag = True Then
       Call DBClose_Click
     End If
     gstDataType = MSACCESS
     gstDBName = newname
     OpenLocalDB True
   End If
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo CompactAccEnd
CompactAccErr:
  MsgBar NULL_STR, False
  ResetMouse Me
  ShowError
  Resume CompactAccEnd
CompactAccEnd:
End Sub
Sub DBNew_Click (Index As Integer)
  Dim nn As String
  Dim d As Database
  Dim v10 As Integer
  Dim driver As String
  On Error GoTo NewDBErr
  Select Case Index
    Case 0   'access
      nn = InputBox("Enter Name for New MS Access Database:")
      If Len(nn) = 0 Then Exit Sub
      If MsgBox("Make New Database Access 1.1 Compatible?", MSGBOX_TYPE) = YES Then
        Set d = CreateDatabase(nn, DB_CREATE_GENERAL, 1)
      Else
        Set d = CreateDatabase(nn, DB_CREATE_GENERAL)
      End If
      d.Close
      gstDataType = MSACCESS
      gstDBName = nn
      OpenLocalDB True
      If gfDBOpenFlag = True Then
        DBProperties.Visible = True
        DBClose.Visible = True
        TblMenu.Visible = True
        UtilMenu.Visible = True
        RefreshTables fTables.cTableList, True
        fSQL.CreateQueryDefbtn.Visible = True
        TblAttach.Visible = True
      End If
    Case 1   'dbase 3
      gstDataType = DBASEIII
      NewLocalISAM
    Case 2   'dbase 4
      gstDataType = dBASEIV
      NewLocalISAM
    Case 3   'fox 2.0
      gstDataType = FOXPRO20
      NewLocalISAM
    Case 4   'fox 2.5
      gstDataType = FOXPRO25
      NewLocalISAM
    Case 5   'paradox 3.x
      gstDataType = PARADOX
      NewLocalISAM
    Case 6   'paradox 4.x
    Case 7   'btrieve
      gstDataType = BTRIEVE
      NewLocalISAM
    Case 8   'odbc
      MsgBar "Enter New Database Parameters", False
      'driver must be an valid entry in ODBCINST.INI
      driver = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", DEFAULTDRIVER)
      RegisterDatabase NULL_STR, driver, False, NULL_STR
      SendKeys "%FOO"   'force open database dialog
  End Select
  MsgBar NULL_STR, False
  Exit Sub
NewDBErr:
  ShowError
  Exit Sub
End Sub
Sub DBOpen_Click (Index As Integer)
  Select Case Index
    Case 0   'access
      gstDataType = MSACCESS
      OpenLocalDB False
    Case 1   'dbase 3
      gstDataType = DBASEIII
      OpenLocalDB False
    Case 2   'dbase 4
      gstDataType = dBASEIV
      OpenLocalDB False
    Case 3   'fox 2.0
      gstDataType = FOXPRO20
      OpenLocalDB False
    Case 4   'fox 2.5
      gstDataType = FOXPRO25
      OpenLocalDB False
    Case 5   'paradox 3.x
      gstDataType = PARADOX
      OpenLocalDB False
    Case 6   'paradox 4.x
    Case 7   'btrieve
      gstDataType = BTRIEVE
      OpenLocalDB False
    Case 8   'odbc
      If gfDBOpenFlag = True Then
        Call DBClose_Click
      End If
      If gfDBOpenFlag = True Then
        Beep
        MsgBox "You must Close First!", 48
      Else
        fOpenDB.Show MODAL
      End If
      If gfDBOpenFlag = True Then
        DBProperties.Visible = True
        DBClose.Visible = True
        TblMenu.Visible = True
        UtilMenu.Visible = True
        RefreshTables fTables.cTableList, True
        fSQL.CreateQueryDefbtn.Visible = False
        TblAttach.Visible = False
        cPassThru.Visible = True
      End If
  End Select
End Sub
Sub DBProperties_Click ()
   Dim f As New fDataBox
   Dim s As String, t As String, erm As String
   Dim i As Integer
   On Error GoTo PropErr
   f.Caption = gCurrentDB.Name & " Properties"
   f.Tag = "DB"
   erm = "Name"
   f.cData.AddItem "Database Name = " & gCurrentDB.Name
   erm = "Connect"
   f.cData.AddItem "Connect String = " & gCurrentDB.Connect
   erm = "Collating Order"
   f.cData.AddItem "Collating Order = " & gCurrentDB.CollatingOrder
   erm = "Updatable"
   f.cData.AddItem "Updatable = " & stTrueFalse((gCurrentDB.Updatable))
   erm = "Transactions"
   f.cData.AddItem "Transactions = " & stTrueFalse((gCurrentDB.Transactions))
   erm = "QueryTimeout"
   f.cData.AddItem "Query Timeout = " & gCurrentDB.QueryTimeout & " seconds"
   f.Show MODAL
  GoTo DBPropEnd
PropErr:
  f.cData.AddItem erm & ":" & Error$
  Resume Next
DBPropEnd:
End Sub
Sub DBRepairDB_Click ()
   On Error GoTo RepairAccErr
   Dim nn As String
   'get file name to repair
   CMD1.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
   CMD1.DialogTitle = "Open MS Access Database to Repair"
   CMD1.FilterIndex = 1
   CMD1.Action = 1
   If Len(CMD1.Filename) > 0 Then
     nn = CMD1.Filename
   Else
     Exit Sub
   End If
   SetHourglass Me
   MsgBar "Repairing " & nn, True
   RepairDatabase nn
   ResetMouse Me
   MsgBar NULL_STR, False
   If MsgBox("Open Repaired Database?", MSGBOX_TYPE) = YES Then
     If gfDBOpenFlag = True Then
       Call DBClose_Click
     End If
     gstDataType = MSACCESS
     gstDBName = nn
     OpenLocalDB True
   End If
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo RepairAccEnd
RepairAccErr:
  ResetMouse Me
  MsgBar NULL_STR, False
  ShowError
  Resume RepairAccEnd
RepairAccEnd:
End Sub
Sub Exit_Click ()
  Unload Me
End Sub
Sub MDIForm_Load ()
  Dim st As String
  Dim x As Integer
  On Error GoTo MDILErr
  'write ISAM entries in INI file just in case
  x = OSWritePrivateProfileString("Installable ISAMS", "Paradox 3.X", "PDX200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "dBASE III", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "dBASE IV", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "FoxPro 2.0", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "FoxPro 2.5", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "Btrieve", "BTRV200.DLL", "VISDATA.INI")
'  x = OSWritePrivateProfileString("dBase ISAM", "Deleted", "On", "VISDATA.INI")
  'point to the VISDATA.INI file so even if you are running
  'from VB, VISDATA.INI is still used
  Dim tmp As String
  tmp = String$(255, 32)
  x = OSGetWindowsDirectory(tmp, 255)
  st = Mid$(tmp, 1, x)
  SetDataAccessOption 1, st & "\visdata.ini"
  'login to Jet
  On Error Resume Next
  SetDefaultWorkspace "admin", NULL_STR
  If Err = 3029 Then
    LoginFrm.Show MODAL
  End If
  On Error GoTo MDILErr
  'get INI settings
  gwMaxGridRows = Val(GetINIString("MaxRows", "250"))
  glQueryTimeout = Val(GetINIString("QueryTimeout", "5"))
  glLoginTimeout = Val(GetINIString("LoginTimeout", "20"))
  st = GetINIString("ViewMode", "Single")
  If st = "Single" Then
    cSingleRecord.Value = True
  ElseIf st = "DataCtl" Then
    cDataCtl.Value = True
  ElseIf st = "DynaGrid" Then
    cTableView.Value = True
  Else
    cTableViewSS.Value = True    'must be snap grid
  End If
  st = GetINIString("OpenOnStartup", "No")
  If UCase(st) = "YES" Then
    PrefOpenOnStartup.Checked = True
  Else
    PrefOpenOnStartup.Checked = False
  End If
  st = GetINIString("ShowPerf", "No")
  If UCase(st) = "YES" Then
    PrefShowPerf.Checked = True
  Else
    PrefShowPerf.Checked = False
  End If
  st = GetINIString("AllowSys", "No")
  If UCase(st) = "YES" Then
    PrefAllowSys.Checked = True
  Else
    PrefAllowSys.Checked = False
  End If
  st = GetINIString("DisplaySQL", "No")
  If UCase(st) = "YES" Then
    PrefDisplaySQL.Checked = True
  Else
    PrefDisplaySQL.Checked = False
  End If
  'get the last used database out of the INI file
  gstDataType = GetINIString("DataType", NULL_STR)
  gstDBName = GetINIString("Server", NULL_STR)
  gstDataBase = GetINIString("DataBase", NULL_STR)
  gstUserName = GetINIString("UserName", NULL_STR)
  gstPassword = GetINIString("Password", NULL_STR)
  cPassThru.Value = Val(GetINIString("PassThru", NULL_STR))
  If PrefOpenOnStartup.Checked = True Then
    If gstDataType = MSACCESS Then
      SendKeys "%FOM"
    ElseIf gstDataType = DBASEIII Then
      SendKeys "%FOD"
    ElseIf gstDataType = dBASEIV Then
      SendKeys "%FOA"
    ElseIf gstDataType = FOXPRO20 Then
      SendKeys "%FOF"
    ElseIf gstDataType = FOXPRO25 Then
      SendKeys "%FOX"
    ElseIf gstDataType = PARADOX Then
      SendKeys "%FOP"
    ElseIf gstDataType = BTRIEVE Then
      SendKeys "%FOB"
    ElseIf gstDataType = SQLDB Then
      SendKeys "%FOO"
    End If
  End If
  x = Val(GetINIString("WindowState", "2"))
  If x <> 1 Then
    WindowState = x
  Else
    WindowState = 0
  End If
  If x = 0 Then
    x = Val(GetINIString("WindowLeft", "0"))
    Left = x
    x = Val(GetINIString("WindowTop", "0"))
    Top = x
    x = Val(GetINIString("WindowWidth", "9135"))
    Width = x
    x = Val(GetINIString("WindowHeight", "6900"))
    Height = x
  End If
  Me.Show
  'load the child forms
  fTables.Show
  fSQL.Show
  Exit Sub
MDILErr:
  ShowError
  End
End Sub
Sub MDIForm_QueryUnload (Cancel As Integer, UnloadMode As Integer)
  Dim x As Integer
  Dim st As String
  On Error Resume Next
  CRLF = Chr(13) & Chr(10)
  x = OSWritePrivateProfileString("VISDATA", "DataType", gstDataType, "VISDATA.INI")
'  If Len(gstDBName) > 0 Then x = OSWritePrivateProfileString("VISDATA", "Server", gstDBName, "VISDATA.INI")
'  If Len(gstDatabase) > 0 Then x = OSWritePrivateProfileString("VISDATA", "DataBase", gstDatabase, "VISDATA.INI")
'  If Len(gstUSerName) > 0 Then x = OSWritePrivateProfileString("VISDATA", "UserName", gstUSerName, "VISDATA.INI")
'  If Len(gstPassword) > 0 Then x = OSWritePrivateProfileString("VISDATA", "Password", gstPassword, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "Server", gstDBName, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "DataBase", gstDataBase, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "UserName", gstUserName, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "Password", gstPassword, "VISDATA.INI")
  If PrefOpenOnStartup.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "OpenOnStartup", st, "VISDATA.INI")
  If PrefShowPerf.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "ShowPerf", st, "VISDATA.INI")
  If PrefAllowSys.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "AllowSys", st, "VISDATA.INI")
  If PrefDisplaySQL.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "DisplaySQL", st, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "WindowState", CStr(WindowState), "VISDATA.INI")
  If WindowState <> 2 Then
    x = OSWritePrivateProfileString("VISDATA", "WindowTop", CStr(Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowLeft", CStr(Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowWidth", CStr(Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowHeight", CStr(Height), "VISDATA.INI")
  End If
  x = OSWritePrivateProfileString("VISDATA", "MaxRows", CStr(gwMaxGridRows), "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "QueryTimeout", CStr(glQueryTimeout), "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "LoginTimeout", CStr(glLoginTimeout), "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "PassThru", CStr(cPassThru), "VISDATA.INI")
  If VDMDI.cSingleRecord = True Then
    st = "Single"
  ElseIf VDMDI.cDataCtl = True Then
    st = "DataCtl"
  ElseIf VDMDI.cTableView = True Then
    st = "DynaGrid"
  Else
    st = "SnapGrid"
  End If
  x = OSWritePrivateProfileString("VISDATA", "ViewMode", st, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "SQLStatement", fSQL.cSQLStatement, "VISDATA.INI")
  If fSQL.WindowState <> 1 Then
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowTop", CStr(fSQL.Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowLeft", CStr(fSQL.Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowWidth", CStr(fSQL.Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowHeight", CStr(fSQL.Height), "VISDATA.INI")
  End If
  If fTables.WindowState <> 1 Then
    x = OSWritePrivateProfileString("VISDATA", "TBLWindowTop", CStr(fTables.Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "TBLWindowLeft", CStr(fTables.Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "TBLWindowWidth", CStr(fTables.Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "TBLWindowHeight", CStr(fTables.Height), "VISDATA.INI")
  End If
  If gfDBChanged Then
    If MsgBox("Data has been changed, Commit it?", MSGBOX_TYPE) = YES Then
      gCurrentDB.CommitTrans
    End If
  End If
  gTableListSS.Close
  CloseAllDynasets
  gCurrentDB.Close
  End
End Sub
Sub MDIForm_Resize ()
  PicOutlines Picture1, cMsg
End Sub
Sub NewLocalISAM ()
   Dim nn As String
   Dim d As Database
   On Error GoTo NewISAMErr
   nn = InputBox("Enter Name for New ISAM Database:")
   If Len(nn) = 0 Then Exit Sub
   If Mid(nn, Len(nn), 1) <> "\" Then nn = nn & "\"
   MkDir Mid(nn, 1, Len(nn) - 1)
   gstDBName = nn
   OpenLocalDB True
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo NewISAMEnd
NewISAMErr:
  If Err = 75 Then Resume Next  'catch the case where dir exists
  ShowError
  Resume NewISAMEnd
NewISAMEnd:
End Sub
Sub OpenLocalDB (doit As Integer)
   Dim Connect As String, DataBaseName As String
   On Error GoTo OpenError
   If gfDBOpenFlag = True Then
     Call DBClose_Click
   End If
   If gfDBOpenFlag = True Then
     Beep
     MsgBox "You must Close First!", 48
     Exit Sub
   Else
     Select Case gstDataType
       Case MSACCESS
         CMD1.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
         CMD1.DialogTitle = "Open MS Access Database"
       Case "dBASE III"
         CMD1.Filter = "dBASE III DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open dBASE III Database"
       Case "dBASE IV"
         CMD1.Filter = "dBASE IV DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open dBASE IV Database"
       Case "FoxPro 2.0"
         CMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open FoxPro 2.0 Database"
       Case "FoxPro 2.5"
         CMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open FoxPro 2.5 Database"
       Case "Paradox 3.X"
         CMD1.Filter = "Paradox DBs (*.db)|*.db"
         CMD1.DialogTitle = "Open Paradox 3.X Database"
       Case "Btrieve"
         CMD1.Filter = "Btrieve DBs (FILE.DDF)|FILE.DDF"
         CMD1.DialogTitle = "Open Btrieve Database"
     End Select
     CMD1.FilterIndex = 1
     CMD1.Filename = gstDBName  '""
     CMD1.CancelError = True
     CMD1.Flags = &H400
     If doit = False Then
       CMD1.Action = 1
       If Len(CMD1.Filename) > 0 Then
         gstDBName = CMD1.Filename
       Else
         Exit Sub
       End If
     End If
   End If
   MsgBar "Opening DataBase", True
   SetHourglass Me
   Select Case gstDataType
     Case DBASEIII
       Connect = "dBASE III"
       DataBaseName = StripFileName(gstDBName)
     Case dBASEIV
       Connect = "dBASE IV"
       DataBaseName = StripFileName(gstDBName)
     Case FOXPRO20
       Connect = "FoxPro 2.0"
       DataBaseName = StripFileName(gstDBName)
     Case FOXPRO25
       Connect = "FoxPro 2.5"
       DataBaseName = StripFileName(gstDBName)
     Case PARADOX
       Connect = "Paradox 3.X"
       DataBaseName = StripFileName(gstDBName)
     Case BTRIEVE
       Connect = "Btrieve;"
       DataBaseName = gstDBName
     Case Else
       Connect = NULL_STR
       DataBaseName = gstDBName
   End Select
   If (CMD1.Flags And 1) = 1 Then
     Set gCurrentDB = OpenDatabase(DataBaseName, False, True, Connect)
   Else
     Set gCurrentDB = OpenDatabase(DataBaseName, False, False, Connect)
   End If
   If gfDBOpenFlag = True Then
     CloseAllDynasets
   End If
   gfTransPending = False
   VDMDI.ToolBar.Visible = True
   VDMDI.QueryBuilder.Visible = True
   VDMDI.cPassThru.Visible = False
   fTables.Caption = gstDBName
   gCurrentDB.QueryTimeout = glQueryTimeout
   'success
   gfDBOpenFlag = True
   DBProperties.Visible = True
   DBClose.Visible = True
   TblMenu.Visible = True
   UtilMenu.Visible = True
   RefreshTables fTables.cTableList, True
   If gstDataType = MSACCESS Then
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
     fTables.TableListLabel.Caption = "Tables/Queries:"
   Else
     TblAttach.Visible = False
     fSQL.CreateQueryDefbtn.Visible = False
   End If
   If gstDataType = DBASEIII Or gstDataType = dBASEIV Or gstDataType = FOXPRO20 Or gstDataType = FOXPRO25 Then
     TblPack.Visible = True
   Else
     TblPack.Visible = False
   End If
   ResetMouse Me
   GoTo OpenEnd
OpenError:
   ResetMouse Me
   gfDBOpenFlag = False
   gstDBName = NULL_STR
   gstDataType = NULL_STR
   gstDataBase = NULL_STR
   gstUserName = NULL_STR
   gstPassword = NULL_STR
   If Err <> 32755 Then     'check for common dialog cancelled
     ShowError
   End If
   Resume OpenEnd
OpenEnd:
End Sub
Sub PrefAllowSys_Click ()
  If PrefAllowSys.Checked = True Then
    PrefAllowSys.Checked = False
  Else
    PrefAllowSys.Checked = True
  End If
  RefreshTables fTables.cTableList, True
End Sub
Sub PrefDisplaySQL_Click ()
  If PrefDisplaySQL.Checked = True Then
    PrefDisplaySQL.Checked = False
  Else
    PrefDisplaySQL.Checked = True
  End If
End Sub
Sub PrefLoginTimeout_Click ()
  On Error GoTo LTErr
  Dim nval As String
  nval = InputBox("Login Timeout is currently " & glLoginTimeout & " seconds." & CRLF & "Enter New Value:")
  If Len(nval) = 0 Then Exit Sub
  'try to set the new value
  If Val(nval) >= 0 Then
    glLoginTimeout = Val(nval)
  End If
  GoTo LTEnd
LTErr:
  ShowError
  Resume LTEnd
LTEnd:
End Sub
Sub PrefMaxRows_Click ()
  Dim st As String
  Dim CR As String
  MsgBar "Enter Maximum Rows to Show in Grid", False
  st = InputBox("Enter New Value:", "Max Grid View Rows", CStr(gwMaxGridRows))
  If Len(st) > 0 Then
    If Val(st) > MAX_GRID_ROWS Then
      MsgBox "Maximum Rows is " & CStr(MAX_GRID_ROWS), 48
      gwMaxGridRows = MAX_GRID_ROWS
    ElseIf Val(st) = 0 Then
      MsgBox "Minimum Rows is 1.", 48
      gwMaxGridRows = 1
    Else
      gwMaxGridRows = Val(st)
    End If
  End If
  MsgBar NULL_STR, False
End Sub
Sub PrefOpenOnStartup_Click ()
  'toggle the menu item
  If PrefOpenOnStartup.Checked = True Then
    PrefOpenOnStartup.Checked = False
  Else
    PrefOpenOnStartup.Checked = True
  End If
End Sub
Sub PrefQueryTimeout_Click ()
  On Error GoTo QTErr
  Dim nval As String
  nval = InputBox("Query Timeout is currently " & gCurrentDB.QueryTimeout & " seconds." & CRLF & "Enter New Value:")
  If Len(nval) = 0 Then Exit Sub
  'try to set the new value
  gCurrentDB.QueryTimeout = Val(nval)
  glQueryTimeout = Val(nval)
  GoTo QTEnd
QTErr:
  ShowError
  'reset the form control after the error
  glQueryTimeout = gCurrentDB.QueryTimeout
  Resume QTEnd
QTEnd:
End Sub
Sub PrefShowPerf_Click ()
  If PrefShowPerf.Checked = True Then
    PrefShowPerf.Checked = False
  Else
    PrefShowPerf.Checked = True
  End If
End Sub
Sub QueryBuilder_Click ()
  fQuery.WindowState = 0
End Sub
Sub RollBackButton_Click ()
  On Error GoTo RollbackErr
  If MsgBox("All changes will be gone, Rollback anyway?", MSGBOX_TYPE) = YES Then
    gCurrentDB.Rollback
    gfDBChanged = False
    gfTransPending = False
    BeginButton.Visible = True
    CommitButton.Visible = False
    RollBackButton.Visible = False
    BeginButton.SetFocus
  End If
  GoTo DBRollbackEnd
RollbackErr:
  ShowError
  Resume DBRollbackEnd
DBRollbackEnd:
End Sub
Sub RptDesign_Click ()
'  On Error GoTo RDErr
'  Dim ret
'  If Dir$("\vb\report\crw.exe") = NULL_STR Then
'    CMD1.Filter = "Crystal Report Designer (CRW.EXE)|CRW.EXE"
'    CMD1.Action = 1
'    If Len(CMD1.Filename) = 0 Then Exit Sub
'    ret = Shell(CMD1.Filename, 4)
'  Else
'    ret = Shell("\vb\report\crw.exe", 4)
'  End If
'  Exit Sub
'RDErr:
'  ShowError
'  Exit Sub
End Sub
Sub RptRun_Click ()
'  On Error GoTo RRErr
'  CMD1.Filter = "Report Files (*.RPT)|*.RPT"
'  CMD1.Action = 1
'  If Len(CMD1.Filename) = 0 Then Exit Sub
'  If gstDataType = "ODBC" Then
'    Report1.Connect = InputBox("Enter Connect String if necessary:")
'  End If
'  Report1.ReportFileName = CMD1.Filename
'  Report1.Action = 1
'  Exit Sub
'RRErr:
'  ShowError
'  Exit Sub
End Sub
Sub TblAttach_Click ()
  fAttach.Show MODAL
End Sub
Sub TblCopyStruct_Click ()
  fCpyStru.Show MODAL
End Sub
Sub TblDelete_Click ()
  On Error GoTo TblDelErr
  If Len(fTables.cTableList.Text) = 0 Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  If MsgBox("Delete """ & fTables.cTableList & """ table?", MSGBOX_TYPE) = YES Then
    If TableType((fTables.cTableList)) = DB_QUERYDEF Then
      gCurrentDB.DeleteQueryDef (fTables.cTableList)
    Else
      gCurrentDB.TableDefs.Delete gCurrentDB.TableDefs(fTables.cTableList)
    End If
    fTables.cTableList.RemoveItem fTables.cTableList.ListIndex
  End If
  GoTo TblDelEnd
TblDelErr:
  ShowError
  Resume TblDelEnd
TblDelEnd:
End Sub
Sub TblPack_Click ()
  Dim ts As String, i As Integer
  ReDim idxs(0) As Index
  If Len(fTables.cTableList.Text) = 0 Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  On Error GoTo PackErr
  If MsgBox("Remove All Deleted Records in " & fTables.cTableList & "?", MSGBOX_TYPE) = YES Then
    SetHourglass Me
    MsgBar "Packing '" & fTables.cTableList & "'", True
    ts = gCurrentDB.Name & "\"
    If Dir$(ts & "p_a_c_k.db?") <> NULL_STR Then
      Kill ts & "p_a_c_k.db?"
    End If
    For i = 0 To gCurrentDB.TableDefs(fTables.cTableList).Indexes.Count - 1
      ReDim Preserve idxs(i + 1)
      Set idxs(i) = New Index
      idxs(i).Name = gCurrentDB.TableDefs(fTables.cTableList).Indexes(i).Name
      idxs(i).Fields = gCurrentDB.TableDefs(fTables.cTableList).Indexes(i).Fields
      idxs(i).Primary = gCurrentDB.TableDefs(fTables.cTableList).Indexes(i).Primary
      idxs(i).Unique = gCurrentDB.TableDefs(fTables.cTableList).Indexes(i).Unique
    Next
    gCurrentDB.Execute "Select * into p_a_c_k from " & fTables.cTableList
    gCurrentDB.TableDefs.Delete fTables.cTableList
    Name ts & "p_a_c_k.dbf" As ts + fTables.cTableList & ".dbf"
    If Dir$(ts & "p_a_c_k.dbt") <> NULL_STR Then
      Name ts & "p_a_c_k.dbt" As ts + fTables.cTableList & ".dbt"
    End If
    gCurrentDB.TableDefs.Refresh
    For i = 0 To UBound(idxs) - 1
      gCurrentDB.TableDefs(fTables.cTableList).Indexes.Append idxs(i)
    Next
    MsgBox "'" & fTables.cTableList & "' successfully Packed!", 48
  End If
  ResetMouse Me
  MsgBar "", False
  GoTo PackEnd
PackErr:
  ResetMouse Me
  MsgBar "", False
  ShowError
  Resume PackEnd
PackEnd:
End Sub
Sub TblProperties_Click ()
   Dim f As New fDataBox
   Dim erm As String
   Dim tt As Integer
   Dim qt As String
   Dim qd As QueryDef
   If Len(fTables.cTableList.Text) = 0 Then
     MsgBox "No Table Selected", 48
     Exit Sub
   End If
   On Error GoTo TblPropErr
   f.Caption = fTables.cTableList & " Properties"
   tt = TableType((fTables.cTableList))
   If tt = DB_QUERYDEF Then
     f.cData.AddItem "Table Type = QueryDef"
   ElseIf tt = DB_ATTACHEDTABLE Then
     f.cData.AddItem "Table Type = Attached Table"
   ElseIf tt = DB_ATTACHEDODBC Then
     f.cData.AddItem "Table Type = Attached ODBC Table"
   Else
     f.cData.AddItem "Table Type = Table"
   End If
   If tt = DB_QUERYDEF Then
     f.Tag = "QD"
     Set gCurrentQueryDef = gCurrentDB.OpenQueryDef(fTables.cTableList)
     erm = "Name"
     f.cData.AddItem "QueryDef Name = " & gCurrentQueryDef.Name
     erm = "SQL"
     f.cData.AddItem "SQL = " & gCurrentQueryDef.SQL
     qt = ActionQueryType((fTables.cTableList))
     If Len(qt) > 0 Then
       f.cData.AddItem "Action Query Type = " & qt
     End If
     f.Show MODAL
     gCurrentQueryDef.Close
   Else
     f.Tag = "TBD"
     erm = "Name"
     f.cData.AddItem "Table Name = " & gCurrentDB.TableDefs(fTables.cTableList).Name
     erm = "Date Created"
     f.cData.AddItem "Date Created = " & gCurrentDB.TableDefs(fTables.cTableList).DateCreated
     erm = "Last Updated"
     f.cData.AddItem "Last Updated = " & gCurrentDB.TableDefs(fTables.cTableList).LastUpdated
     erm = "Updatable"
     f.cData.AddItem "Updatable = " & stTrueFalse((gCurrentDB.TableDefs(fTables.cTableList).Updatable))
     erm = "Connect"
     f.cData.AddItem "Connect String = " & gCurrentDB.TableDefs(fTables.cTableList).Connect
     erm = "Source Table Name"
     f.cData.AddItem "Source Table Name = " & gCurrentDB.TableDefs(fTables.cTableList).SourceTableName
     erm = "Attributes"
     f.cData.AddItem "Attributes = &H" & Hex(gCurrentDB.TableDefs(fTables.cTableList).Attributes)
     f.Show MODAL
   End If
  GoTo TblPropEnd
TblPropErr:
  f.cData.AddItem erm & ":" & Error$
  Resume Next
TblPropEnd:
End Sub
Sub TblRefresh_Click ()
  gCurrentDB.TableDefs.Refresh
  RefreshTables fTables.cTableList, True
End Sub
Sub TblZap_Click ()
  Dim RetSQL As Long
  If Len(fTables.cTableList.Text) = 0 Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  On Error GoTo ZapErr
  If MsgBox("Delete All Records in " & fTables.cTableList & "?", MSGBOX_TYPE) = YES Then
    'delete all rows with a sql statement
    If gstDataType = SQLDB Then
      RetSQL = gCurrentDB.ExecuteSQL("delete from " & fTables.cTableList)
      If RetSQL > 0 Then
        MsgBox CStr(RetSQL) & " rows deleted!", 48
        If gfTransPending Then gfDBChanged = True
      End If
    Else
      gCurrentDB.Execute ("delete from " & fTables.cTableList)
    End If
  End If
  GoTo ZapEnd
ZapErr:
  If Err = EOF_ERR Then Resume Next
  ShowError
  Resume ZapEnd
ZapEnd:
End Sub
Sub UtilCloseAll_Click ()
  CloseAllDynasets
End Sub
Sub UtilImportExport_Click ()
  VBIMEX.Show MODAL
End Sub
Sub UtilReplace_Click ()
  Dim i As Integer
  Dim sb As String
  On Error GoTo ReplaceErr
  RefreshTables fReplace.cTableList, False
  fReplace.Show MODAL
  GoTo ReplaceEnd
ReplaceErr:
  ShowError
  Resume ReplaceEnd
ReplaceEnd:
End Sub
Sub WinArrange_Click ()
  Me.Arrange 3
End Sub
Sub WinCascade_Click ()
  Me.Arrange 0
End Sub
Sub WinSQL_Click ()
  fSQL.WindowState = 0
End Sub
Sub WinTables_Click ()
  fTables.WindowState = 0
  If fTables.cTableList.ListCount = 0 And gfDBOpenFlag = True Then
    RefreshTables fTables.cTableList, True
  End If
End Sub
Sub WinTile_Click ()
  Me.Arrange 2
End Sub